home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / balloon / balloon.bas < prev    next >
Encoding:
BASIC Source File  |  1995-05-09  |  6.6 KB  |  153 lines
  1. Type PointAPI
  2.     x As Integer
  3.     y As Integer
  4. End Type
  5.  
  6. Type Size
  7.     cx As Integer
  8.     cy As Integer
  9. End Type
  10.  
  11. Type Rect
  12.     xTopLeft As Integer
  13.     yTopLeft As Integer
  14.     xBottomRight As Integer
  15.     yBottomRight As Integer
  16. End Type
  17.  
  18. Global Const SRCCOPY = &HCC0020
  19. Global WindRect As Rect
  20. Global WindowPos As PointAPI
  21. Global HintFlag As Integer, WindowHandle As Integer
  22. Global HintHandle As Integer, HintBitMap As Integer
  23. Global RecArea As Rect, RecWidth As Integer, RecHeight As Integer
  24.  
  25. Declare Function CreateDC Lib "GDI" (ByVal lpDriverName As String, ByVal lpDeviceName As Any, ByVal lpOutput As Any, ByVal lpInitData As Any) As Integer
  26. Declare Sub GetCursorPos Lib "User" (lpPoint As PointAPI)
  27. Declare Function GetTextExtentPoint Lib "GDI" (ByVal hDC As Integer, ByVal lpszString As String, ByVal cbString As Integer, lpSize As Size) As Integer
  28. Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC As Integer) As Integer
  29. Declare Function Rectangle Lib "GDI" (ByVal hDC As Integer, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
  30. Declare Function RoundRect Lib "GDI" (ByVal hDC As Integer, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer, ByVal X3 As Integer, ByVal Y3 As Integer) As Integer
  31. Declare Function TextOut Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal lpString As String, ByVal nCount As Integer) As Integer
  32. Declare Function CreateCompatibleBitmap Lib "GDI" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
  33. Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
  34. Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
  35. Declare Function DeleteDC Lib "GDI" (ByVal hDC As Integer) As Integer
  36. Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
  37. Declare Sub GetWindowRect Lib "User" (ByVal hWnd As Integer, lpRect As Rect)
  38. Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer
  39. Declare Sub SetSysColors Lib "User" (ByVal nChanges As Integer, lpSysColor As Integer, lpColorValues As Long)
  40. Declare Function SetBkColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
  41. Declare Function CreateFont Lib "GDI" (ByVal H%, ByVal W%, ByVal E%, ByVal O%, ByVal W%, ByVal I%, ByVal U%, ByVal S%, ByVal C%, ByVal OP%, ByVal CP%, ByVal Q%, ByVal PAF%, ByVal F$) As Integer
  42. Declare Function SetMapMode Lib "GDI" (ByVal hDC As Integer, ByVal nMapMode As Integer) As Integer
  43.  
  44. Sub CheckBalloon (TheForm As Form)
  45.  
  46.     Dim MousePointer As PointAPI
  47.     Dim WindRectTemp As Rect
  48.  
  49.     Call GetWindowRect(TheForm.hWnd, WindRectTemp)
  50.     Call GetCursorPos(MousePointer)
  51.  
  52.     If MousePointer.x < WindRectTemp.xTopLeft Or MousePointer.y < WindRectTemp.yTopLeft Or MousePointer.y > WindRectTemp.yBottomRight Then
  53.         Call RemBalloon(TheForm)
  54.     End If
  55.     
  56. End Sub
  57.  
  58. Sub PutBalloon (MyString As String, TheForm As Form)
  59.     
  60.     Dim MousePointer As PointAPI
  61.     Dim MyStringSize As Size
  62.     Dim RecRegion As Integer
  63.     Dim BrushHandle As Integer
  64.     ReDim BottomPoints(2) As PointAPI
  65.     Dim FontName As String
  66.     Dim FontSize As Integer
  67.     Dim FontHandle As Integer
  68.     Dim FontWeight As Integer
  69.     
  70.     If HintFlag = 0 Then
  71.         
  72.         HintFlag = 1
  73.         
  74.         Call GetWindowRect(TheForm.hWnd, WindRect)
  75.  
  76.         WindowHandle = CreateDC("Display", ByVal 0&, ByVal 0&, ByVal 0&)
  77.         HintHandle = CreateCompatibleDC(WindowHandle)
  78.         
  79.         FontName = "Courier New"
  80.         FontSize = 16
  81.         FontWeight = 800
  82.         FontHandle = CreateFont(FontSize, 0, 0, 0, FontWeight, 0, 0, 0, 0, 0, 0, 0, 0, FontName)
  83.         Dummy% = SelectObject(WindowHandle, FontHandle)
  84.  
  85.         Dummy% = GetTextExtentPoint(WindowHandle, MyString, Len(MyString), MyStringSize)
  86.         
  87.         Call GetCursorPos(MousePointer)
  88.         
  89.         RecArea.xTopLeft = MousePointer.x + 10
  90.         RecArea.yTopLeft = MousePointer.y + 10
  91.         RecArea.xBottomRight = MousePointer.x + MyStringSize.cx + 18
  92.         RecArea.yBottomRight = MousePointer.y + MyStringSize.cy + 18
  93.         RecWidth = RecArea.xBottomRight - RecArea.xTopLeft
  94.         RecHeight = RecArea.yBottomRight - RecArea.yTopLeft
  95.         
  96.         Do Until RecArea.xBottomRight < WindRect.xBottomRight Or RecArea.xBottomRight < 0
  97.             RecArea.xBottomRight = RecArea.xBottomRight - 5
  98.             RecArea.xTopLeft = RecArea.xTopLeft - 5
  99.         Loop
  100.  
  101.         If RecArea.xBottomRight > WindRect.xBottomRight Or RecArea.xTopLeft < WindRect.xTopLeft Or RecArea.xBottomRight < 0 Then
  102.             Exit Sub
  103.         End If
  104.  
  105.         HintBitMap = CreateCompatibleBitmap(WindowHandle, RecWidth, RecHeight)
  106.         Dummy% = SelectObject(HintHandle, HintBitMap)
  107.         Dummy% = BitBlt(HintHandle, 0, 0, RecWidth, RecHeight, WindowHandle, RecArea.xTopLeft, RecArea.yTopLeft, SRCCOPY)
  108.                   
  109.         BottomPoints(1).x = RecArea.xBottomRight
  110.         BottomPoints(1).y = RecArea.yBottomRight
  111.         BottomPoints(2).x = RecArea.xTopLeft
  112.         BottomPoints(2).y = RecArea.yBottomRight
  113.         
  114.         Color& = RGB(255, 255, 0)
  115.         BrushHandle = CreateSolidBrush(Color&)
  116.         Dummy% = SelectObject(WindowHandle, BrushHandle)
  117.  
  118.         Dummy% = RoundRect(WindowHandle, RecArea.xTopLeft, RecArea.yTopLeft, RecArea.xBottomRight, RecArea.yBottomRight, 20, 20)
  119.         WinBackColor = SetBkColor(WindowHandle, Color&)
  120.         Dummy% = SelectObject(WindowHandle, FontHandle)
  121.         Dummy% = TextOut(WindowHandle, RecArea.xTopLeft + 4, RecArea.yTopLeft + 4, MyString, Len(MyString))
  122.                            
  123.         
  124.  
  125.     End If
  126.  
  127. End Sub
  128.  
  129. Sub RemBalloon (TheForm As Form)
  130.  
  131.     Dim WindRectNew As Rect
  132.     
  133.     If HintFlag = 1 Then
  134.         
  135.         Call GetWindowRect(TheForm.hWnd, WindRectNew)
  136.     
  137.         RecArea.xTopLeft = RecArea.xTopLeft + (WindRectNew.xTopLeft - WindRect.xTopLeft)
  138.         RecArea.yTopLeft = RecArea.yTopLeft + (WindRectNew.yTopLeft - WindRect.yTopLeft)
  139.     
  140.         HintFlag = 0
  141.         Dummy% = BitBlt(WindowHandle, RecArea.xTopLeft, RecArea.yTopLeft, RecWidth, RecHeight, HintHandle, 0, 0, SRCCOPY)
  142.         Dummy2& = SetBkColor(WindowHandle, WinBackColor)
  143.         Dummy% = DeleteDC(WindowHandle)
  144.         Dummy% = DeleteDC(HintHandle)
  145.         Dummy% = DeleteObject(HintBitMap)
  146.         Dummy% = DeleteObject(BrushHandle)
  147.         BalloonHint = ""
  148.  
  149.     End If
  150.  
  151. End Sub
  152.  
  153.